home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / PowerMacOberon feb96 / Source / POPM.Mod (.txt) < prev    next >
Encoding:
Oberon Text  |  1996-01-25  |  14.2 KB  |  360 lines  |  [TEXT/.Ob4]
  1. Syntax10b.Scn.Fnt
  2. Syntax10.Scn.Fnt
  3. Syntax10i.Scn.Fnt
  4. MODULE POPM;    (* RC 6.3.89 / 19.10.92, mmb 4.3.91 / 30.10.92 *)
  5. (* Machine dependent constants needed before code generation *)
  6. (* Host interface, IBM RS/6000 version *)
  7. (* modifications HM: *)
  8. (* 94-05-09 MaxPtr and MaxGPtr smaller *)
  9. (* 94-05-24 Sysflag 1 for records => 68K alignment in records (MaxSysFlag = 1 instead of 0) *)
  10.     IMPORT
  11.         Texts, Oberon, Files, SYSTEM;
  12.     CONST (* IBM RS/6000 *)
  13.         (* basic type sizes *)
  14.         ByteSize* = 1;    (* SYSTEM.BYTE *)
  15.         CharSize* = 1;    (* CHAR *)
  16.         BoolSize* = 1;    (* BOOLEAN *)
  17.         SetSize* = 4;    (* SET *)
  18.         SIntSize* = 1;    (* SHORTINT *)
  19.         IntSize* = 2;    (* INTEGER *)
  20.         LIntSize* = 4;    (* LONGINT *)
  21.         RealSize* = 4;    (* REAL *)
  22.         LRealSize* = 8;    (* LONGREAL *)
  23.         ProcSize* = 8;    (* PROCEDURE type *)
  24.         PointerSize* = 4;    (* POINTER type *)
  25.         (* value of constant NIL *)
  26.         nilval* = 0;
  27.         (* target machine minimum values of basic types expressed in host machine format: *)
  28.         MinSInt* = -80H;
  29.         MinInt* = -8000H;
  30.         MinLInt* =  80000000H;    (*-2147483648*)
  31.         MinRealPat = 0FF7FFFFFH;    (* most  negative, 32-bit pattern *)
  32.         MinLRealPatL = 0FFEFFFFFH;    (* most  negative, lower 32-bit pattern *)
  33.         MinLRealPatH = 0FFFFFFFFH;    (* most  negative, higher 32-bit pattern *)
  34.         (* target machine maximum values of basic types expressed in host machine format: *)
  35.         MaxSInt* = 7FH;
  36.         MaxInt* = 7FFFH;
  37.         MaxLInt* = 7FFFFFFFH;    (*2147483647*)
  38.         MaxSet* = 31;    (* must be >= 15, else the bootstraped compiler cannot run (IN-tests) *)
  39.         MaxRealPat = 7F7FFFFFH;    (* most positive, 32-bit pattern *)
  40.         MaxLRealPatL = 7FEFFFFFH;    (* most positive, lower 32-bit pattern *)
  41.         MaxLRealPatH = 0FFFFFFFFH;        (* most positive, higher 32-bit pattern *)
  42.         (* maximal index value for array declaration: *)
  43.         MaxIndex* = MaxLInt;
  44.         (* parametrization of numeric scanner: *)
  45.         MaxHDig* = 8;    (* maximal hexadecimal longint length *)
  46.         MaxRExp* = 38;    (* maximal real exponent *)
  47.         MaxLExp* = 308;    (* maximal longreal exponent *)
  48.         (* inclusive range of parameter of standard procedure HALT: *)
  49.         MinHaltNr* = 20;
  50.         MaxHaltNr* = 255;
  51.         (* inclusive range of register number of procedures SYSTEM.GETREG and SYSTEM.PUTREG: *)
  52.         MinRegNr* = 0;
  53.         MaxRegNr* = 66;    (* 0..31: Rx or FPRx, depending on second operand, 32..66: control registers *)
  54.         (* encoding: code = 32+reg
  55.             MQ = 0; XER = 1; fromRTCU = 4; fromRTCL = 5; fromDEC = 6; LR = 8; CTR = 9;
  56.             CR = 32; MSR = 33; FPSCR = 34;
  57.             others are privileged
  58.         (* maximal value of flag used to mark interface structures: *)
  59.         MaxSysFlag* = 1;    (* IBM RS/6000: only 0 is valid, not used *)
  60.         (* maximal condition value of parameter of SYSTEM.CC: *)
  61.         MaxCC* = -1;    (* IBM RS/6000: not used *)
  62.         (* initialization of linkadr field in ObjDesc, must be different from any valid link address: *)
  63.         LANotAlloc* = -1;
  64.         (* initialization of constant address, must be different from any valid constant address: *)
  65.         ConstNotAlloc* = -1;    (* IBM RS/6000: only strings are allocated *)
  66.         (* initialization of tdadr field in StrDesc, must be different from any valid address: *)
  67.         TDAdrUndef* = -1;
  68.         (* maximal number of cases in a case statement: *)
  69.         MaxCases* = 128;
  70.         (* maximal range of a case statement (higher label - lower label ~ jump table size): *)
  71.         MaxCaseRange* = 512;
  72.         (* maximal number of exit statements within a (nested) loop statement: *)
  73.         MaxExit* = 16;
  74.         (* whether hidden pointer fields have to be nevertheless exported: *)
  75.         ExpHdPtrFld* = TRUE;
  76.         HdPtrName* = "@ptr";
  77.         (* whether hidden procedure fields have to be nevertheless exported (may be used for System.Free): *)
  78.         ExpHdProcFld* = FALSE;
  79.         HdProcName* = "@proc";
  80.         (* whether hidden bound procedures have to be nevertheless exported: *)
  81.         ExpHdTProc* = FALSE;
  82.         HdTProcName* = "@tproc";
  83.         (* maximal number of hidden fields in an exported record: *)
  84.         MaxHdFld* = 512;
  85.         (* whether addresses of formal parameters are exported: *)
  86.         ExpParAdr* = TRUE;
  87.         (* whether addresses or entry numbers are exported for global variables: *)
  88.         ExpVarAdr* = TRUE;
  89.         (* maximal number of exported stuctures: *)
  90.         MaxStruct* = 255;    (* must be < 256 *)
  91.         (* maximal number of pointer fields in a record: *)
  92.         MaxPtr* = (*16384*) 1024;
  93.         (* maximal number of global pointers: *)
  94.         MaxGPtr* = (*16384*) 1024;
  95.         (* whether field leaf of pointer variable p has to be set to FALSE, when NEW(p) or SYSTEM.NEW(p, n) is used: *)
  96.         NEWusingAdr* = FALSE;
  97.         (* special character (< " ") returned by procedure Get, if end of text reached *)
  98.         Eot* = 0X;
  99.         (* version flag *)
  100.         CeresVersion* = FALSE;
  101.         MinReal*, MaxReal*: REAL;
  102.         MinLReal*, MaxLReal*: LONGREAL;
  103.         noerr*: BOOLEAN;    (* no error found until now *)
  104.         curpos*, errpos*: LONGINT;    (* character and error position in source file *)
  105.         breakpc*: LONGINT;    (* set by OPV.Init *)
  106.     CONST
  107.         SFext = ".Sym";
  108.         SFtag = 0F7X;    (* symbol file tag *)
  109.         OFext = ".Obj";
  110.         OFtag = 0F8X;    (* object file tag *)
  111.     TYPE
  112.         FileName = ARRAY 32 OF CHAR;
  113.         LRealPat: RECORD L, H: LONGINT END ;
  114.         lastpos, pat: LONGINT;    (* last position error in source file *)
  115.         inR: Texts.Reader;
  116.         Log: Texts.Text;
  117.         W: Texts.Writer;
  118.         oldSF, newSF, ObjF, RefF: Files.Rider;
  119.         oldSFile, newSFile, ObjFile, RefFile: Files.File;
  120.         Path: FileName;
  121.         now301: BOOLEAN;
  122.     PROCEDURE FlipBits* (i: LONGINT): LONGINT;
  123.         VAR s, d: SET;
  124.     BEGIN
  125.         IF CeresVersion THEN
  126.             s := SYSTEM.VAL(SET, i); d := {}; i := 0;
  127.             WHILE i < 32 DO IF i IN s THEN INCL(d, 31-i) END; INC(i) END;
  128.             RETURN SYSTEM.VAL(LONGINT, d)
  129.         ELSE
  130.             RETURN i
  131.         END
  132.     END FlipBits;
  133.     PROCEDURE FlipBytes (VAR b: ARRAY OF SYSTEM.BYTE);
  134.         VAR i, j: INTEGER; h: SYSTEM.BYTE;
  135.     BEGIN i := 0; j := SHORT(LEN(b))-1;
  136.         WHILE i < j DO h := b[i]; b[i] := b[j]; b[j] := h; INC(i); DEC(j) END
  137.     END FlipBytes;
  138.     PROCEDURE Init* (source: Texts.Reader; log: Texts.Text);
  139.     BEGIN inR := source; Log := log;
  140.         noerr := TRUE; curpos := Texts.Pos(inR); errpos := curpos; lastpos := curpos-10; now301 := FALSE
  141.     END Init;
  142.     PROCEDURE Get* (VAR ch: CHAR);    (* read next character from source text, Eot if no more *)
  143.     BEGIN Texts.Read(inR, ch); INC(curpos)
  144.     END Get;
  145.     PROCEDURE NewKey* (): LONGINT;
  146.         VAR time, date: LONGINT;
  147.     BEGIN Oberon.GetClock(time, date); RETURN (time MOD 20000H) * (date MOD 4000H)
  148.     END NewKey;
  149.     PROCEDURE MakeFileName (VAR name, FName: ARRAY OF CHAR; ext: ARRAY OF CHAR);
  150.         VAR i, j: INTEGER; ch: CHAR;
  151.     BEGIN i := 0;
  152.         LOOP ch := name[i];
  153.             IF ch = 0X THEN EXIT END ;
  154.             FName[i] := ch; INC(i);
  155.         END ;
  156.         j := 0;
  157.         REPEAT ch := ext[j]; FName[i] := ch; INC(i); INC(j)
  158.         UNTIL ch = 0X
  159.     END MakeFileName;
  160.     (* ------------------------- Log Output ------------------------- *)
  161.     PROCEDURE LogW* (ch: CHAR);
  162.     BEGIN
  163.         Texts.Write(W, ch); Texts.Append(Log, W.buf)
  164.     END LogW;
  165.     PROCEDURE LogWStr* (s: ARRAY OF CHAR);
  166.     BEGIN
  167.         Texts.WriteString(W, s); Texts.Append(Log, W.buf)
  168.     END LogWStr;
  169.     PROCEDURE LogWNum* (i, len: LONGINT);
  170.     BEGIN
  171.         Texts.WriteInt(W, i, len); Texts.Append(Log, W.buf)
  172.     END LogWNum;
  173.     PROCEDURE LogWHex (i: LONGINT);
  174.     BEGIN
  175.         Texts.WriteHex(W, i); Texts.Write(W, "H"); Texts.Append(Log, W.buf)
  176.     END LogWHex;
  177.     PROCEDURE LogWLn*;
  178.     BEGIN
  179.         Texts.WriteLn(W); Texts.Append(Log, W.buf)
  180.     END LogWLn;
  181.     PROCEDURE Mark* (n: INTEGER; pos: LONGINT);
  182.     BEGIN
  183.         IF n >= 0 THEN
  184.             noerr := FALSE;
  185.             IF (pos < lastpos) OR (lastpos + 9 < pos) THEN lastpos := pos;
  186.                 LogWLn; LogWStr("  pos"); LogWNum(pos, 6);
  187.                 IF n = 255 THEN LogWStr("  pc "); LogWHex(breakpc)
  188.                 ELSIF n = 254 THEN LogWStr("  pc not found")
  189.                 ELSE LogWStr("  err"); LogWNum(n, 4)
  190.                 END
  191.             END
  192.         ELSE
  193.             LogWLn; LogWStr("  pos"); LogWNum(pos, 6); LogWStr("  warning"); LogWNum(-n, 4)
  194.         END
  195.     END Mark;
  196.     PROCEDURE err* (n: INTEGER);
  197.     BEGIN
  198.         IF n = -10000 THEN now301 := TRUE; RETURN END;
  199.         IF (n = -301) & now301 THEN RETURN END;
  200.         Mark(n, errpos)
  201.     END err;
  202.     (* ------------------------- Read Symbol File ------------------------- *)
  203.     PROCEDURE SymRCh* (VAR b: CHAR);
  204.     BEGIN Files.Read(oldSF, b)
  205.     END SymRCh;
  206.     PROCEDURE SymRTag* (VAR k: INTEGER);
  207.         VAR i: LONGINT;
  208.     BEGIN Files.ReadNum(oldSF, i); k := SHORT(i)
  209.     END SymRTag;
  210.     PROCEDURE SymRInt* (VAR k: LONGINT);
  211.     BEGIN Files.ReadNum(oldSF, k)
  212.     END SymRInt;
  213.     PROCEDURE SymRLInt* (VAR k: LONGINT);
  214.     BEGIN Files.ReadNum(oldSF, k)
  215.     END SymRLInt;
  216.     PROCEDURE SymRSet* (VAR s: SET);
  217.         VAR j: LONGINT;
  218.     BEGIN Files.ReadNum(oldSF, j);
  219.         IF CeresVersion THEN j := FlipBits(j) END;
  220.         s := SYSTEM.VAL(SET, j)
  221.     END SymRSet;
  222.     PROCEDURE SymRReal* (VAR r: REAL);
  223.     BEGIN Files.ReadReal(oldSF, r)
  224.     END SymRReal;
  225.     PROCEDURE SymRLReal* (VAR lr: LONGREAL);
  226.     BEGIN Files.ReadLReal(oldSF, lr)
  227.     END SymRLReal;
  228.     PROCEDURE CloseOldSym*;
  229.     (* called only if OldSym previously returned done = TRUE *)
  230.     END CloseOldSym;
  231.     PROCEDURE OldSym* (VAR modName: ARRAY OF CHAR; self: BOOLEAN; VAR done: BOOLEAN);
  232.     (* open file in read mode *)
  233.         VAR ch: CHAR; fileName: FileName;
  234.     BEGIN MakeFileName(modName, fileName, SFext);
  235.         oldSFile := Files.Old(fileName); done := oldSFile # NIL;
  236.         IF done THEN
  237.             Files.Set(oldSF, oldSFile, 0); SymRCh(ch);
  238.             IF ch # SFtag THEN err(151);  (*not a symbol file*)
  239.                 CloseOldSym; done := FALSE
  240.             END
  241.         ELSIF ~self THEN err(152)   (*sym file not found*)
  242.         END
  243.     END OldSym;
  244.     PROCEDURE eofSF* (): BOOLEAN;
  245.     (* = TRUE if end of old file reached *)
  246.     BEGIN RETURN oldSF.eof
  247.     END eofSF;
  248.     (* ------------------------- Write Symbol File ------------------------- *)
  249.     PROCEDURE SymWCh* (ch: CHAR);
  250.     BEGIN Files.Write(newSF, ch)
  251.     END SymWCh;
  252.     PROCEDURE SymWTag* (k: INTEGER);
  253.     BEGIN Files.WriteNum(newSF, k)
  254.     END SymWTag;
  255.     PROCEDURE SymWInt* (i: LONGINT);
  256.     BEGIN Files.WriteNum(newSF, i)
  257.     END SymWInt;
  258.     PROCEDURE SymWLInt* (k: LONGINT);
  259.     BEGIN Files.WriteNum(newSF, k)
  260.     END SymWLInt;
  261.     PROCEDURE SymWSet* (s: SET);
  262.     BEGIN
  263.         IF CeresVersion THEN
  264.             Files.WriteNum(newSF, FlipBits(SYSTEM.VAL(LONGINT, s)))
  265.         ELSE
  266.             Files.WriteNum(newSF, SYSTEM.VAL(LONGINT, s))
  267.         END
  268.     END SymWSet;
  269.     PROCEDURE SymWReal* (r: REAL);
  270.     BEGIN Files.WriteReal(newSF, r)
  271.     END SymWReal;
  272.     PROCEDURE SymWLReal* (lr: LONGREAL);
  273.     BEGIN Files.WriteLReal(newSF, lr)
  274.     END SymWLReal;
  275.     PROCEDURE RegisterNewSym* (VAR modName: ARRAY OF CHAR);
  276.     (* delete possibly already existing file with same name, register new created file *)
  277.     BEGIN Files.Register(newSFile)
  278.     END RegisterNewSym;
  279.     PROCEDURE DeleteNewSym*;
  280.     (* delete new created file, don't touch possibly already existing file with same name *)
  281.     END DeleteNewSym;
  282.     PROCEDURE NewSym* (VAR modName: ARRAY OF CHAR; VAR done: BOOLEAN);
  283.     (* open new file in write mode, don't touch possibly already existing file with same name *)
  284.         VAR fileName: FileName;
  285.     BEGIN MakeFileName(modName, fileName, SFext);
  286.         newSFile := Files.New(fileName); done := newSFile # NIL;
  287.         IF done THEN Files.Set(newSF, newSFile, 0);
  288.             SymWCh(SFtag)
  289.         ELSE err(153)
  290.         END
  291.     END NewSym;
  292.     PROCEDURE EqualSym* (VAR oldkey: LONGINT): BOOLEAN;
  293.     (* compare old and new Symbol File, close old file, return TRUE if equal *)
  294.         VAR ch0, ch1: CHAR; equal: BOOLEAN; newkey: LONGINT;
  295.     BEGIN
  296.         Files.Set(oldSF, oldSFile, 2); Files.ReadNum(oldSF, oldkey);
  297.         Files.Set(newSF, newSFile, 2); Files.ReadNum(newSF, newkey);
  298.         REPEAT Files.Read(oldSF, ch0); Files.Read(newSF, ch1)
  299.         UNTIL (ch0 # ch1) OR newSF.eof;
  300.         equal := oldSF.eof & newSF.eof; CloseOldSym;
  301.         RETURN equal
  302.     END EqualSym;
  303.     (* ------------------------- Write Reference & Object Files ------------------------- *)
  304.     PROCEDURE RefW* (ch: CHAR);
  305.     BEGIN Files.Write(RefF, ch)
  306.     END RefW;
  307.     PROCEDURE RefWNum* (i: LONGINT);
  308.     BEGIN Files.WriteNum(RefF, i)
  309.     END RefWNum;
  310.     PROCEDURE RefWBytes* (VAR bytes: ARRAY OF SYSTEM.BYTE; n: LONGINT);    (* MK *)
  311.     BEGIN Files.WriteBytes(RefF, bytes, n)
  312.     END RefWBytes;
  313.     PROCEDURE RefPos* (): LONGINT;         (* MK *)
  314.     BEGIN RETURN Files.Pos(RefF)
  315.     END RefPos;
  316.     PROCEDURE ObjW* (ch: CHAR);
  317.     BEGIN Files.Write(ObjF, ch)
  318.     END ObjW;
  319.     PROCEDURE ObjWInt* (i: INTEGER);
  320.     BEGIN
  321.         Files.WriteBytes(ObjF, i, 2)
  322.     END ObjWInt;
  323.     PROCEDURE ObjWLInt* (i: LONGINT);
  324.     BEGIN
  325.         Files.WriteBytes(ObjF, i, 4)
  326.     END ObjWLInt;
  327.     PROCEDURE ObjWBytes* (VAR bytes: ARRAY OF SYSTEM.BYTE; n: LONGINT);
  328.     BEGIN Files.WriteBytes(ObjF, bytes, n)
  329.     END ObjWBytes;
  330.     PROCEDURE OpenRefObj* (VAR modName: ARRAY OF CHAR);
  331.         VAR FName: ARRAY 32 OF CHAR;
  332.     BEGIN
  333.         RefFile := Files.New(""); Files.Set(RefF, RefFile, 0);
  334.         MakeFileName(modName, FName, OFext);
  335.         ObjFile := Files.New(FName);
  336.         IF ObjFile # NIL THEN
  337.             Files.Set(ObjF, ObjFile, 0);
  338.             ObjW(OFtag); ObjW("6"); ObjWInt(0); ObjWInt(0)
  339.         ELSE err(153)
  340.         END
  341.     END OpenRefObj;
  342.     PROCEDURE CloseRefObj*;
  343.         VAR refsize: LONGINT; ch: CHAR; ref: Files.Rider;
  344.     BEGIN (*ref block*)
  345.         refsize := Files.Length(RefFile); ObjW(8BX);
  346.         Files.Set(ref, RefFile, 0); Files.Read(ref, ch);
  347.         WHILE ~ref.eof DO ObjW(ch); Files.Read(ref, ch) END ;
  348.         Files.Set(ObjF, ObjFile, 2); ObjWLInt(refsize); (*ObjWBytes(refsize, 4);*)
  349.         Files.Register(ObjFile)
  350.     END CloseRefObj;
  351. BEGIN
  352.     pat := MinRealPat; SYSTEM.MOVE(SYSTEM.ADR(pat), SYSTEM.ADR(MinReal), 4);    (*-3.40282346E38*)
  353.     pat := MaxRealPat; SYSTEM.MOVE(SYSTEM.ADR(pat), SYSTEM.ADR(MaxReal), 4);    (*3.40282346E38*)
  354.     LRealPat.L := MinLRealPatL; LRealPat.H := MinLRealPatH;
  355.     SYSTEM.MOVE(SYSTEM.ADR(LRealPat), SYSTEM.ADR(MinLReal), 8);    (*-1.7976931348623157D308*)
  356.     LRealPat.L := MaxLRealPatL; LRealPat.H := MaxLRealPatH;
  357.     SYSTEM.MOVE(SYSTEM.ADR(LRealPat), SYSTEM.ADR(MaxLReal), 8);    (*1.7976931348623157D308*)
  358.     Texts.OpenWriter(W); Log := Oberon.Log
  359. END POPM.
  360.